home *** CD-ROM | disk | FTP | other *** search
/ The Very Best of Atari Inside / The Very Best of Atari Inside 1.iso / sharew / accs / ramdisk / r_backup.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1985-07-19  |  33.5 KB  |  805 lines
  1.  
  2. {///////////////////////////////////////////////////////////////////////////}
  3. {/                                                                         /}
  4. {/  RAM - BACKUP : Kopiert Dateien zwischen Laufwerken und Unterverzeich-  /}
  5. {/                 nissen als Backup ( d.h. alte Version wird umbenannt    /}
  6. {/                 in .BAK, neue Version wird unter dem Namen gesichert).  /}
  7. {/                                                                         /}
  8. {/  Dieses PUBLIC DOMAIN Programm wurde 1986 mit ST Pascal plus von CCD    /}
  9. {/  entwickelt, 1987 und 1988 erweitert von                                /}
  10. {/                                                   ERHARD SCHWARTZ       /}
  11. {/                                                   Isaraustraße 8        /}
  12. {/  Version 1.61 vom 19.04.88                    D - 8192 Geretsried 1     /}
  13. {/                                                                         /}
  14. {/                                                                         /}
  15. {/  NEU : Um auch  Anfängern und Umsteigern den  Einstieg in diese schöne  /}
  16. {/        Programmiersprache  zu  erleichtern, sind  ab sofort  auch  die  /}
  17. {/        Pascal-Sources meiner Programme PUBLIC DOMAIN.                   /}
  18. {/        Sollte  jedoch jemand dieses Programm selbst oder zumindest die  /}
  19. {/        Source als Anregung für eigene Programme gut gebrauchen können,  /}
  20. {/        so bitte ich um  Überweisung eines kleinen Unkostenbeitrags auf  /}
  21. {/        folgendes Konto:                                                 /}
  22. {/        Kreissparkasse Wolfratshausen, BLZ 70054306, Konto-Nr. 670588    /}
  23. {/                                                                         /}
  24. {/                                                                         /}
  25. {/  Änderungen am Programm ab Version :                                    /}
  26. {/                                                                         /}
  27. {/  1.60 - Umstellung auf ST Pascal Plus Version 2.0                       /}
  28. {/       - Intelligenteres Behandeln der Dateipfade bei erneutem Aufruf    /}
  29. {/  1.61 - Etwas mehr Farbenpracht für die vernachlässigten Color - Fans   /}
  30. {/                                                                         /}
  31. {///////////////////////////////////////////////////////////////////////////}
  32.  
  33. {$A+} { Programm soll ein Accessory werden   }
  34. {$S5} { Heap und Stack mit 5k                }
  35. {$D-} { Ohne Debug                           }
  36. {$P-} { Keine Überprüfung von Zeigern        }
  37. {$R-} { Keine Unterbereichsprüfung           }
  38. {$T-} { Keine Überprüfung von Heap und Stack }
  39.  
  40.  
  41. PROGRAM ACCESSORY_BACKUP_by_ERHARD_SCHWARTZ;
  42.  
  43. {$I GEM.INC}    { GEM.INC enthält die Dateien GEMCONST.PAS mit vorange- }
  44.                 { stelltem CONST, GEMTYPE.PAS mit vorangestelltem TYPE  }
  45.                 { sowie GEMSUBS.PAS. Warum also auf 3 Dateien verteilt, }
  46.                 { wenns ab ST-Pascal Plus V. 2.0 auch mit einer geht ?  }
  47.  
  48. {$I TRIX.INC}   { Gleiches Verfahren wie mit dem GEM - Routinen         }
  49.  
  50. CONST 
  51.  
  52. (***********************************************)
  53. (**                                           **)
  54. (**)    VERSION         = '1.61';            (**)
  55. (**                                           **)
  56. (***********************************************)
  57.  
  58.         MENU_EINTRAG    = '  RAM - Backup';
  59.         BOX_LEN         = 52;
  60.         MUSTER          = 17;
  61.         MAXBYTE         = 1024;
  62.  
  63. TYPE    ext_typ         = STRING[3];
  64.  
  65.         rwbuftyp        = PACKED ARRAY[1..MAXBYTE] OF CHAR;
  66.  
  67.         dtabuftyp = RECORD              { Struktur des DTA-Puffers }
  68.                       dos    : PACKED ARRAY[0..21] OF CHAR;
  69.                       time,
  70.                       date   : INTEGER;
  71.                       size   : LONG_INTEGER;
  72.                       name   : PACKED ARRAY[1..14] OF CHAR;
  73.                     END;
  74.  
  75. VAR     ap_id,
  76.         menu_id,
  77.         mist,
  78.         wahl            : INTEGER;
  79.  
  80.         dl              : dialog_ptr;
  81.  
  82.         angemeldet      : SET OF CHAR;
  83.  
  84.         q_drive,                        { Laufwerk für Quelle und Ziel }
  85.         z_drive         : CHAR;
  86.  
  87.         q_dr_str,                       { Diverse Strings }
  88.         z_dr_str,
  89.         t,
  90.         frag_leer,
  91.         acc_name        : str255;
  92.  
  93.         quell_btn,                      { Namen aus dem Dialog }
  94.         ziel_btn,
  95.         ordner_btn,
  96.         quell_name,
  97.         ziel_name,
  98.         quell_drive,
  99.         ziel_drive,
  100.         start_btn,
  101.         cancel_btn      : INTEGER;
  102.  
  103.         erfolg,                                 { Flags }
  104.         kopier_stop     : BOOLEAN;
  105.  
  106.         in_fil_pfad,
  107.         out_fil_pfad,
  108.         pfad_anf,
  109.         letzt_ord,
  110.         datei_name      : path_name;
  111.         extension,
  112.         q_ext           : ext_typ;
  113.  
  114.         fenster,                        { Daten des Hintergrundfensters }
  115.         fenst_x,
  116.         fenst_y,
  117.         fenst_w,
  118.         fenst_h         : INTEGER;
  119.         fenstername     : window_title;
  120.  
  121.  
  122. {///////////////////////////////////////////////////////////////////////////}
  123. {///  Definition der benötigten BIOS- und GEMDOS - Routinen   //////////////}
  124. {///////////////////////////////////////////////////////////////////////////}
  125.  
  126.  
  127. FUNCTION  dgetdrv                               : INTEGER;      GEMDOS($19);
  128. PROCEDURE fsetdta( VAR dtabuf : dtabuftyp);                     GEMDOS($1A);
  129. FUNCTION  dcreate( VAR path : c_string )        : INTEGER;      GEMDOS($39);
  130. FUNCTION  fcreate( VAR nam : c_string; att:INTEGER): INTEGER;   GEMDOS($3C);
  131. FUNCTION  fopen  ( VAR nam : c_string; att:INTEGER): INTEGER;   GEMDOS($3D);
  132. FUNCTION  fclose ( handle : INTEGER)            : INTEGER;      GEMDOS($3E);
  133. FUNCTION  fread  ( handle : INTEGER; cnt : LONG_INTEGER;
  134.                    VAR rwbuf : rwbuftyp) : LONG_INTEGER;        GEMDOS($3F);
  135. FUNCTION  fwrite ( handle : INTEGER; cnt : LONG_INTEGER;
  136.                    VAR rwbuf : rwbuftyp) : LONG_INTEGER;        GEMDOS($40);
  137. FUNCTION  fdelete( VAR nam : c_string)          : INTEGER;      GEMDOS($41);
  138. FUNCTION  frename( res:INTEGER; VAR q, z:c_string)  : INTEGER;  GEMDOS($56);
  139.  
  140.  
  141. {///////////////////////////////////////////////////////////////////////////}
  142. {///  Hier werden einige Voreinstellungen gemacht   ////////////////////////}
  143. {///////////////////////////////////////////////////////////////////////////}
  144.  
  145. PROCEDURE initialisiere;
  146. VAR     i       : INTEGER;
  147.         logged_drive    : CHAR;
  148. BEGIN
  149.   logged_drive := chr( dgetdrv + 65);
  150.   z_drive := logged_drive;      { Als Ziel wird Bootlaufwerk genommen }
  151.  
  152.   q_drive := 'Q';                       { Laufwerke gehen von A bis P }
  153.   REPEAT q_drive := pred( q_drive)      { Höchstes Laufwerk als Quelle }
  154.   UNTIL q_drive IN angemeldet;          { ... da vermutlich die Ramdisk }
  155.   IF q_drive = 'B' THEN q_drive := logged_drive;        { Aber nicht B }
  156.  
  157.   erfolg         := FALSE;
  158.   in_fil_pfad    := '';
  159.   out_fil_pfad   := '';
  160.   q_ext          := '*';              { Voreinstellung : *.* }
  161.  
  162.   frag_leer := '   ???   keine Angabe   ???';
  163.   FOR i := length(frag_leer) + 1 TO BOX_LEN DO frag_leer[i] := ' ';
  164.   frag_leer[0] := chr(BOX_LEN);
  165. END; { procedure initialisiere }
  166.  
  167.  
  168. {///////////////////////////////////////////////////////////////////////////}
  169. {///   Ermittlung der angemeldeten Laufwerke   /////////////////////////////}
  170. {///////////////////////////////////////////////////////////////////////////}
  171.  
  172. PROCEDURE erlaubte_laufwerke;
  173. VAR     map     : INTEGER;
  174.         ch      : CHAR;
  175.   FUNCTION  drvmap        : INTEGER;                            BIOS ( 10);
  176. BEGIN
  177.   angemeldet := [];             { Zunächst kein angemeldetes Laufwerk }
  178.   map := drvmap;
  179.   FOR ch := 'A' TO 'P' DO
  180.   BEGIN
  181.     IF ( map & $01) = $01                       { Angemeldete Laufwerke }
  182.     THEN angemeldet := angemeldet + [ch];       { im Bitvektor suchen }
  183.     map := shr( map, 1);                        { Bits um eine Position }
  184.   END; { for - Schleife }                       { nach rechts schieben }
  185. END; { procedure erlaubte_laufwerke }
  186.  
  187.  
  188. {///////////////////////////////////////////////////////////////////////////}
  189. {///   U P C A S E   wandelt in Großbuchstaben um   ////////////////////////}
  190. {///////////////////////////////////////////////////////////////////////////}
  191.  
  192. FUNCTION upcase ( ch : CHAR ) : CHAR;
  193. BEGIN
  194.   IF ( ch >= 'a') AND ( ch <= 'z' )
  195.   THEN upcase := chr( ord( ch) - 32 )
  196.   ELSE CASE ch OF
  197.          'ä'  : upcase := 'Ä';
  198.          'ö'  : upcase := 'Ö';
  199.          'ü'  : upcase := 'Ü';
  200.          ELSE : upcase := ch;
  201.        END; { case }
  202. END; { upcase }
  203.  
  204.  
  205. {///////////////////////////////////////////////////////////////////////////}
  206. {///   Analysiert einen Dateipfad   ////////////////////////////////////////}
  207. {///////////////////////////////////////////////////////////////////////////}
  208.  
  209. PROCEDURE pfad_analyse( VAR ur_pfad, pfad, letzt_ord, name : path_name;
  210.                         VAR ext : ext_typ);
  211. VAR     i,
  212.         len,
  213.         punkt   : INTEGER;
  214. BEGIN
  215.   letzt_ord     := '';  { Zuerst alles löschen }
  216.   name  := '';
  217.   ext   := '';
  218.   pfad  := ur_pfad;     { Pfad kopieren }
  219.   len   := length( pfad);
  220.   IF len > 0    { Alles andere wäre ja unsinnig ! }
  221.   THEN BEGIN
  222.          i     := len;  { Alles von hinten her aufrollen }
  223.          punkt := 0;    { Noch keinen Punkt gefunden }
  224.  
  225.          LOOP           { Zuerst '.' und '\' ermitteln }
  226.            IF pfad[i] = '.' THEN punkt := i;
  227.          EXIT IF (pfad[i] = '\') OR (i = 1);
  228.            i := i - 1;
  229.          END; { loop }
  230.          IF punkt > 0   { Dateiname hatte eine Extension }
  231.          THEN ext := copy( pfad, punkt + 1, len - punkt)
  232.          ELSE punkt := len + 1; { punkt auf Zeichen nach Ende des Namens }
  233.  
  234.          IF i = 1 THEN i := 0;  { i auf Zeichen vor Anfang des Namens }
  235.          name  := copy( pfad, i + 1, punkt - i - 1);
  236.          pfad[0] := chr( i);    { Pfadlänge korrigieren }
  237.  
  238.          IF i > 1       { '\' sollte ja nicht am Anfang stehen }
  239.          THEN BEGIN
  240.                 REPEAT          { Suchen, ob noch ein '\' vorhanden }
  241.                   i := i - 1;
  242.                 UNTIL (pfad[i] = '\') OR (i = 1);
  243.                 IF i > 1        { '\' gefunden }
  244.                 THEN BEGIN
  245.                        letzt_ord := copy( pfad, i + 1, length( pfad) - i);
  246.                                                 { Ordnername kopieren }
  247.                        pfad[0] := chr( i);      { Pfadlänge korrigieren }
  248.                      END;
  249.               END; { Pfad bestand nicht nur aus dem Namen }
  250.        END; { Pfad war kein Leerstring }
  251. END; { pfad_analyse }
  252.  
  253.  
  254. {///////////////////////////////////////////////////////////////////////////}
  255. {///   Hier wird geprüft, ob eine Datei bereits existiert   ////////////////}
  256. {///////////////////////////////////////////////////////////////////////////}
  257.  
  258. FUNCTION exist( filnam : path_name) : BOOLEAN;
  259. VAR     path    : c_string;
  260.   FUNCTION  fsfirst( VAR p : c_string; att:INTEGER) : INTEGER;  GEMDOS($4E);
  261. BEGIN
  262.   PtoCstr( filnam, path);
  263.   exist := fsfirst( path, 0) = NO_ERROR;
  264. END; { function exist }
  265.  
  266.  
  267. {///////////////////////////////////////////////////////////////////////////}
  268. {///   Hier wird die Kopie angefertigt   ///////////////////////////////////}
  269. {///////////////////////////////////////////////////////////////////////////}
  270.  
  271. FUNCTION backup(q_name, z_name: path_name): BOOLEAN;
  272.  
  273. VAR     bak_name        : path_name;
  274.  
  275.         q_pfad,
  276.         z_pfad,
  277.         bak_pfad        : c_string;
  278.  
  279.         q_handle,
  280.         z_handle,
  281.         i               : INTEGER;
  282.  
  283.         dtabuf          : dtabuftyp;
  284.         rwbuf           : rwbuftyp;
  285.  
  286.         datei_laenge    : LONG_INTEGER;
  287.  
  288.         abbruch         : BOOLEAN;
  289.  
  290. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  291. {~~~   Hier werden eventuelle Fehlermeldungen ausgegeben   ~~~~~~~~~~~~~~~~~}
  292. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  293.  
  294.   PROCEDURE backup_alarm( alarm : INTEGER );
  295.   VAR t : str255;
  296.   BEGIN
  297.     CASE alarm OF
  298.     1 : t := '[2][Kann angegebene Quelldatei| |nicht finden][ABBRUCH]';
  299.     2 : t := '[3][Kann angegebene Quelldatei| |nicht öffnen][ABBRUCH]';
  300.     3 : t := '[3][Kann angegebene Zieldatei| |nicht öffnen][ABBRUCH]';
  301.     4 : t := '[3][Fehler beim Einlesen| |der Quelldatei][ABBRUCH]';
  302.     5 : t := '[3][Fehler beim Schreiben| |in Zieldatei][ABBRUCH]';
  303.     6 : t := '[3][Zieldatei konnte nicht| |geschlossen werden][OKAY]';
  304.     7 : t := '[3][Quelldatei konnte nicht| |geschlossen werden][OKAY]';
  305.     8 : t := concat('[3][Alte .BAK-Datei konnte|nicht gelöscht werden.| |',
  306.                     'Status vermutlich "nur lesen"][ABBRUCH]');
  307.     9 : t := '[3][Diskette hat zu wenig| |Speicherplatz][ABBRUCH]';
  308.     10: t := concat('[3][Alte Zieldatei konnte nicht|',
  309.                     'in .BAK umbenannt werden.| |',
  310.                     'Status vermutlich "nur lesen"][ABBRUCH]');
  311.     END; { case }
  312.     mist := do_alert( t, 1);
  313.     abbruch := TRUE;
  314.   END; { procedure backup_alarm }
  315.  
  316.  
  317. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  318. {~~~   Enthält die Kopierschleife    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  319. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  320.  
  321.   PROCEDURE durchlaufe_kopierschleife( rest : LONG_INTEGER);
  322.   VAR   r_byte,
  323.         w_byte,
  324.         copybyte        : LONG_INTEGER;
  325.   BEGIN
  326.     abbruch := FALSE;
  327.     WHILE (rest > 0) AND NOT abbruch DO { Solange, bis fertig oder Fehler }
  328.       BEGIN
  329.         IF rest > MAXBYTE
  330.         THEN copybyte := MAXBYTE        { Maximale Pufferlänge ausnutzen }
  331.         ELSE copybyte := rest;          { ansonsten halt den Rest nehmen }
  332.  
  333.         r_byte := fread(q_handle,copybyte, rwbuf);      { Puffer einlesen }
  334.         IF r_byte <> copybyte                           { Fehler beim Lesen }
  335.         THEN backup_alarm(4)
  336.         ELSE BEGIN      { alles ok }
  337.                w_byte := fwrite(z_handle,copybyte,rwbuf);{ Puffer schreiben }
  338.                IF w_byte <> copybyte    { Schreibfehler ist aufgetreten }
  339.                THEN backup_alarm(5);
  340.              END;
  341.         rest := rest - copybyte;
  342.       END; { while }
  343.     END; { durchlaufe_kopierschleife }
  344.  
  345.  
  346. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  347. {~~~   Fertigt die Kopie an    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  348. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  349.  
  350.   PROCEDURE kopiere_datei;
  351.   BEGIN
  352.     q_handle := fopen(q_pfad, 0);       { Quelldatei öffnen }
  353.     IF q_handle < 0
  354.     THEN backup_alarm(2)                { Fehler, Quelle nicht geöffnet }
  355.     ELSE BEGIN                          { Alles klar, Quelle offen }
  356.            z_handle := fcreate(z_pfad, 0);     { Zieldatei anlegen }
  357.            IF z_handle < 0
  358.            THEN backup_alarm(3)         { Fehler, Ziel nicht geöffnet }
  359.            ELSE durchlaufe_kopierschleife( datei_laenge);
  360.            IF fclose( z_handle) <> NO_ERROR
  361.            THEN backup_alarm(6);        { Fehler, Ziel nicht geschlossen }
  362.          END;                           { Quelle war offen }
  363.     IF fclose( q_handle) <> NO_ERROR
  364.     THEN backup_alarm(7);               { Fehler, Quelle nicht geschlossen }
  365.   END; { kopiere_datei }
  366.  
  367.  
  368. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  369. {~~~   Ermittelt den auf der Diskette vorhandenen Speicherplatz    ~~~~~~~~~}
  370. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  371.  
  372.   FUNCTION speicherplatz( drive : CHAR) : LONG_INTEGER;
  373.   TYPE  p_buf   = RECORD
  374.                     freie_cluster,
  375.                     gesamt_cluster,
  376.                     bytes_pro_sector,
  377.                     sectoren_pro_cluster : LONG_INTEGER;
  378.                   END; { record }
  379.   VAR   platz           : p_buf;
  380.         drive_nr        : INTEGER;
  381.     FUNCTION  dfree  ( VAR p : p_buf; d : INTEGER)  : INTEGER;  GEMDOS($36);
  382.   BEGIN
  383.     drive_nr := ord( drive) - 64;               { A --> 1, B --> 2 etc. }
  384.     IF dfree( platz, drive_nr) = NO_ERROR
  385.     THEN speicherplatz := platz.freie_cluster * platz.sectoren_pro_cluster
  386.                           * platz.bytes_pro_sector
  387.     ELSE speicherplatz := 0;
  388.   END; { function speicherplatz }
  389.  
  390. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  391.  
  392. BEGIN { function backup }
  393.   abbruch := FALSE;
  394.   fsetdta( dtabuf);             { Neue Adresse für DTA-Puffer }
  395.   pfad_analyse( z_name, pfad_anf, letzt_ord, datei_name, extension);
  396.   bak_name := concat( pfad_anf, letzt_ord, datei_name, '.BAK');
  397.                                 { Backup-Datei bekommt Extension .BAK }
  398.   PtoCstr(q_name,   q_pfad);    { C-Pfadnamen aus Dateinamen machen }
  399.   PtoCstr(z_name,   z_pfad);
  400.   PtoCstr(bak_name, bak_pfad);
  401.  
  402.   IF NOT exist(q_name)  { Quell-Datei suchen und DTA-Puffer füllen }
  403.   THEN backup_alarm(1)  { Fehler, Quelldatei existiert nicht }
  404.   ELSE
  405.   BEGIN                 { Alles klar, Quelldatei existiert }
  406.     datei_laenge := dtabuf.size;        { Länge aus DTA-Puffer entnehmen, }
  407.                                         { bevor er überschrieben wird }
  408.     IF exist( bak_name) AND exist( z_name) { Alte .BAK muß gelöscht werden }
  409.     THEN IF fdelete(bak_pfad) <> NO_ERROR
  410.          THEN backup_alarm( 8);         { vermutlich Schreibschutz }
  411.  
  412.     IF NOT abbruch
  413.     THEN
  414.     BEGIN                       { Kopie machen, da bis jetzt kein Fehler }
  415.       IF speicherplatz( z_drive) < datei_laenge
  416.       THEN backup_alarm( 9)     { Zu wenig Speicherplatz }
  417.       ELSE BEGIN                { Alles klar, Speicherplatz reicht aus }
  418.              IF exist(z_name)   { Evtl. alte Datei in .BAK umbenennen }
  419.              THEN IF frename(0, z_pfad, bak_pfad) <> NO_ERROR
  420.                   THEN backup_alarm(10);        { Fehler, Schreibschutz ? }
  421.  
  422.              IF NOT abbruch THEN kopiere_datei; { Jetzt kanns losgehn }
  423.            END;         { Speicherplatz hat ausgereicht }
  424.     END;                { Kopie gemacht, da kein Fehler }
  425.   END;                  { Quelldatei hat existiert }
  426.   backup := NOT abbruch;
  427. END; { function backup }
  428.  
  429.  
  430. {///////////////////////////////////////////////////////////////////////////}
  431. {///   Hier wird das Dialogfeld zusammengebaut   ///////////////////////////}
  432. {///////////////////////////////////////////////////////////////////////////}
  433.  
  434. PROCEDURE baue_dialog;                  { Erstellt das Dialogfeld }
  435. CONST   RA_ST_0         =  0;           { Rahmen-Stärken }
  436.         RA_ST_1I        = -1;
  437.         RA_ST_2I        =  2;
  438.         RA_ST_2A        =  2;
  439.         NORM_FA         = $1181;        { = 0001 0001 1 000 0001 }
  440.                                 { Rahmen, Text, Muster sw, Text drüber }
  441.         RAHMEN_RT       = $2181;        { = 0010 0001 1 000 0001 }
  442.         RAHMEN_GN       = $3181;        { = 0011 0001 1 000 0001 }
  443.         MAX_D_ITEMS     = 18;
  444.  
  445. BEGIN
  446.  
  447. dl      := new_dialog( MAX_D_ITEMS, 0, 0, 70, 20);
  448.  
  449. mist    := add_ditem    ( dl, G_IBOX, NONE, 2,1,66,5, RA_ST_2I, RAHMEN_RT);
  450.            obj_setstate ( dl, mist , OUTLINED , FALSE);
  451.  
  452. mist    := add_ditem    ( dl, G_TEXT, NONE, 2, 1, 66, 2, RA_ST_0, NORM_FA);
  453.            obj_setstate ( dl, mist, NORMAL, FALSE);
  454.            t := concat  ( 'RAM - BACKUP  V ', VERSION,
  455.                           '  * PUBLIC DOMAIN * 1986-88 by E. SCHWARTZ');
  456.            set_dtext    ( dl, mist, t, SYSTEM_FONT, TE_CENTER);
  457.  
  458. mist    := add_ditem    ( dl, G_TEXT, NONE, 2, 3, 66, 1, RA_ST_0, NORM_FA);
  459.            obj_setstate ( dl, mist, NORMAL, FALSE);
  460.            t := concat  ( 'ENTWICKELT MIT ST PASCAL PLUS VON CCD. KLEINE ',
  461.                           'UNKOSTENBEITRÄGE FÜR DIESES PROGRAMM');
  462.            set_dtext    ( dl, mist, t, SMALL_FONT, TE_CENTER);
  463.  
  464. mist    := add_ditem    ( dl, G_TEXT, NONE, 2, 4, 66, 1, RA_ST_0, NORM_FA);
  465.            obj_setstate ( dl, mist, NORMAL, FALSE);
  466.            t := concat  ( 'WERDEN JEDERZEIT GERNE ENTGEGENGENOMMEN VON :   ',
  467.                           'ERHARD SCHWARTZ, ISARAUSTRASSE 8,');
  468.            set_dtext    ( dl, mist, t, SMALL_FONT, TE_CENTER);
  469.  
  470. mist    := add_ditem    ( dl, G_TEXT, NONE, 2, 5, 66, 1, RA_ST_0, NORM_FA);
  471.            obj_setstate ( dl, mist, NORMAL, FALSE);
  472.            t := concat  ( 'D - 8192 GERETSRIED 1.  KONTO-NR. 670588, ',
  473.                           'KREISSPARK. WOLFRATSHAUSEN, BLZ 70054306');
  474.            set_dtext    ( dl, mist, t, SMALL_FONT, TE_CENTER);
  475.  
  476.  
  477. quell_btn := add_ditem  ( dl, G_BUTTON, SELECTABLE|EXIT_BTN, 2, 8, 20, 2,
  478.                           RA_ST_2I, NORM_FA);
  479.              obj_setstate ( dl, quell_btn , OUTLINED, FALSE);
  480.              set_dtext  ( dl, quell_btn, 'Quell-Datei ...', SYSTEM_FONT,
  481.                           TE_CENTER);
  482.  
  483. ziel_btn   := add_ditem ( dl, G_BUTTON, SELECTABLE|EXIT_BTN, 25, 8, 20, 2,
  484.                           RA_ST_2I, NORM_FA);
  485.               obj_setstate ( dl, ziel_btn, OUTLINED|DISABLED, FALSE);
  486.               set_dtext ( dl, ziel_btn, 'Ziel-Datei ...', SYSTEM_FONT,
  487.                           TE_CENTER);
  488.  
  489. ordner_btn := add_ditem ( dl, G_BUTTON , SELECTABLE|EXIT_BTN, 48, 8, 20, 2,
  490.                           RA_ST_2I, NORM_FA);
  491.               obj_setstate ( dl, ordner_btn, OUTLINED, FALSE);
  492.               set_dtext ( dl, ordner_btn, 'Neuer Ordner ...', SYSTEM_FONT,
  493.                           TE_CENTER);
  494.  
  495. mist    := add_ditem    (dl, G_TEXT, NONE, 2, 12, 12, 1, RA_ST_0,  NORM_FA);
  496.            obj_setstate ( dl, mist, NORMAL, FALSE);
  497.            set_dtext    ( dl, mist, 'Kopiere von', SYSTEM_FONT, TE_RIGHT);
  498.  
  499. quell_name := add_ditem ( dl, G_BOXTEXT, NONE,16, 12, BOX_LEN,  1,
  500.                           RA_ST_1I, NORM_FA);
  501.                 obj_setstate ( dl, quell_name, NORMAL, FALSE);
  502.                 set_dtext( dl, quell_name, frag_leer, SYSTEM_FONT, TE_LEFT);
  503.  
  504. mist    := add_ditem    ( dl, G_TEXT, NONE, 2,14,12, 1, RA_ST_0 , NORM_FA);
  505.            obj_setstate ( dl, mist, NORMAL, FALSE);
  506.            set_dtext    ( dl, mist, 'nach', SYSTEM_FONT, TE_RIGHT );
  507.  
  508. ziel_name := add_ditem  ( dl, G_BOXTEXT, NONE, 16, 14, BOX_LEN,  1,
  509.                           RA_ST_1I, NORM_FA);
  510.              obj_setstate ( dl, ziel_name, NORMAL, FALSE);
  511.              set_dtext  ( dl, ziel_name, frag_leer, SYSTEM_FONT, TE_LEFT);
  512.  
  513. mist    := add_ditem    ( dl, G_TEXT, NONE, 2, 17, 12, 2, RA_ST_2A, NORM_FA);
  514.            obj_setstate ( dl, mist, NORMAL, FALSE);
  515.            set_dtext    ( dl, mist, 'Richtung :', SYSTEM_FONT, TE_CENTER);
  516.  
  517. quell_drive := add_ditem( dl, G_FBOXTEXT,EDITABLE, 15, 17, 4, 2, RA_ST_2A,
  518.                           NORM_FA);
  519.                obj_setstate ( dl, quell_drive, NORMAL, FALSE);
  520.                set_dedit( dl, quell_drive, '_', 'a', q_drive, SYSTEM_FONT,
  521.                           TE_CENTER);
  522.  
  523. mist    := add_ditem    (dl, G_TEXT, NONE, 20, 17, 5, 2, RA_ST_2A, NORM_FA);
  524.            obj_setstate ( dl, mist, NORMAL, FALSE);
  525.            set_dtext    ( dl, mist, '--->', SYSTEM_FONT, TE_CENTER);
  526.  
  527. ziel_drive  := add_ditem( dl, G_FBOXTEXT,EDITABLE, 26, 17, 4, 2,
  528.                           RA_ST_2A, NORM_FA);
  529.                obj_setstate ( dl, ziel_drive  , NORMAL, FALSE);
  530.                set_dedit ( dl, ziel_drive ,  '_', 'a', z_drive,
  531.                            SYSTEM_FONT, TE_CENTER);
  532.  
  533. start_btn  := add_ditem( dl,G_BUTTON,SELECTABLE|EXIT_BTN, 38, 17, 13, 2,
  534.                          RA_ST_2A, NORM_FA);
  535.               obj_setstate ( dl,start_btn,OUTLINED|DISABLED|SHADOWED, FALSE);
  536.               set_dtext ( dl,start_btn, 'Los geht''s',SYSTEM_FONT,TE_CENTER);
  537.  
  538. cancel_btn := add_ditem( dl, G_BUTTON , SELECTABLE|EXIT_BTN, 55, 17, 13, 2,
  539.                          RA_ST_2A, NORM_FA);
  540.               obj_setstate ( dl, cancel_btn, OUTLINED, FALSE);
  541.               set_dtext ( dl, cancel_btn, 'Abbruch', SYSTEM_FONT, TE_CENTER);
  542.  
  543. END; { procedure baue_dialog }
  544.  
  545.  
  546. {///////////////////////////////////////////////////////////////////////////}
  547. {///   Gibt bei nicht angemeldetem Laufwerk Fehlermeldung aus   ////////////}
  548. {///////////////////////////////////////////////////////////////////////////}
  549.  
  550. PROCEDURE nicht_angemeldet_alarm( ch : CHAR);
  551. BEGIN
  552.   t := concat( '[1][Laufwerk ', ch, '| |nicht angemeldet !][OKAY]');
  553.   mist := do_alert( t, 1);
  554.   kopier_stop := TRUE;
  555. END; { procedure nicht_angemeldet_alarm }
  556.  
  557.  
  558. {///////////////////////////////////////////////////////////////////////////}
  559. {///   Erstellt neuen Ordner   /////////////////////////////////////////////}
  560. {///////////////////////////////////////////////////////////////////////////}
  561.  
  562. PROCEDURE neuer_ordner;
  563. VAR     ord_pfad,
  564.         vorschlag       : path_name;
  565.         ord_c_pfad      : c_string;
  566. BEGIN
  567.   ord_pfad := '';
  568.   vorschlag := concat( z_drive, ':\*.ORD');
  569.   IF get_in_file( vorschlag, ord_pfad)
  570.   THEN
  571.   BEGIN
  572.     PtoCstr( ord_pfad, ord_c_pfad);
  573.     CASE - dcreate( ord_c_pfad) OF      { Ordner anlegen }
  574.       0  : BEGIN END;
  575.       34 : mist := do_alert('[3][Pfad nicht gefunden !][OKAY]', 1);
  576.       36 : mist := do_alert('[3][Zugriff verweigert !][OKAY]', 1);
  577.       OTHERWISE : mist := do_alert('[3][Unbekannter Fehler][OKAY]', 1);
  578.     END; { case }
  579.   END; { Name wurde ausgewählt }
  580. END; { procedure neuer_ordner }
  581.  
  582.  
  583. {///////////////////////////////////////////////////////////////////////////}
  584. {///   Ermittelt den Namen der Quelldatei   ////////////////////////////////}
  585. {///////////////////////////////////////////////////////////////////////////}
  586.  
  587. PROCEDURE suche_quelldatei;
  588. VAR     vorschlag,
  589.         neu_pfad        : path_name;
  590.         file_erhalten   : BOOLEAN;
  591. BEGIN
  592.   vorschlag := concat( q_drive, ':\*.', q_ext);
  593.   neu_pfad  := in_fil_pfad;
  594.   file_erhalten := get_in_file( vorschlag, neu_pfad);
  595.   IF length( neu_pfad) > BOX_LEN
  596.   THEN BEGIN
  597.          mist:= do_alert('[1][Tut mir leid,| |Pfadname zu lang !][OKAY]', 1);
  598.          file_erhalten := FALSE;
  599.        END; { Name war zu lang }
  600.   pfad_analyse( neu_pfad, pfad_anf, letzt_ord, datei_name, extension);
  601.   IF file_erhalten AND ( datei_name <> '' )
  602.   THEN
  603.   BEGIN
  604.     in_fil_pfad  := neu_pfad;   { Pfad übernehmen }
  605.     IF in_fil_pfad[1] IN angemeldet     { Prüfen, ob Laufwerk angemeldet }
  606.     THEN q_drive := in_fil_pfad[1]
  607.     ELSE BEGIN
  608.            nicht_angemeldet_alarm( in_fil_pfad[1]);
  609.            in_fil_pfad[1] := q_drive;
  610.          END; { Laufwerk nicht Angemeldet }
  611.     pfad_analyse( in_fil_pfad, pfad_anf, letzt_ord, datei_name, q_ext);
  612.                                         { Extension übernehmen }
  613.     IF out_fil_pfad <> ''
  614.     THEN BEGIN
  615.            pfad_analyse( out_fil_pfad, pfad_anf, letzt_ord,
  616.                          neu_pfad, extension);
  617.            out_fil_pfad := concat(pfad_anf,letzt_ord,datei_name,'.',q_ext);
  618.            out_fil_pfad[1] := z_drive;
  619.          END
  620.     ELSE out_fil_pfad := concat( z_drive, ':\', datei_name, '.', q_ext);
  621.  
  622.     obj_setstate( dl, ziel_btn, obj_state(dl,ziel_btn) & ~ DISABLED, FALSE);
  623.     obj_setstate( dl, start_btn,obj_state(dl,start_btn)& ~ DISABLED, FALSE);
  624.                         { Selektierung von Ziel und Los gehts erlauben }
  625.   END; { Quelle ausgesucht }
  626. END; { procedure suche_quelldatei }
  627.  
  628.  
  629. {///////////////////////////////////////////////////////////////////////////}
  630. {///   Ermittelt den Namen der Zieldatei   /////////////////////////////////}
  631. {///////////////////////////////////////////////////////////////////////////}
  632.  
  633. PROCEDURE suche_zieldatei;
  634. VAR     vorschlag,
  635.         neu_pfad        : path_name;
  636.         file_erhalten   : BOOLEAN;
  637. BEGIN
  638.   neu_pfad  := out_fil_pfad;
  639.   pfad_analyse( neu_pfad, pfad_anf, letzt_ord, datei_name, extension);
  640.   vorschlag := concat( pfad_anf,letzt_ord, '*.', q_ext);
  641.   file_erhalten := get_in_file( vorschlag, neu_pfad);
  642.   IF length( neu_pfad) > BOX_LEN
  643.   THEN BEGIN
  644.          mist:= do_alert('[1][Tut mir leid,| |Pfadname zu lang !][OKAY]', 1);
  645.          file_erhalten := FALSE;
  646.        END; { Name war zu lang }
  647.   pfad_analyse( neu_pfad, pfad_anf, letzt_ord, datei_name, extension);
  648.   IF file_erhalten AND ( datei_name <> '' )
  649.   THEN BEGIN
  650.          out_fil_pfad := neu_pfad;
  651.          IF out_fil_pfad[1] IN angemeldet
  652.          THEN z_drive := out_fil_pfad[1]
  653.          ELSE BEGIN
  654.                 nicht_angemeldet_alarm( out_fil_pfad[1]);
  655.                 out_fil_pfad[1] := z_drive;
  656.               END; { Laufwerk nicht Angemeldet }
  657.        END; { File wurde geliefert }
  658. END; { procedure suche_zieldatei }
  659.  
  660.  
  661. {///////////////////////////////////////////////////////////////////////////}
  662. {///   Malt das Hintergrundfenster vollständig aus   ///////////////////////}
  663. {///////////////////////////////////////////////////////////////////////////}
  664.  
  665. PROCEDURE redraw_hintergrund;
  666. TYPE    aufloesung      = ( LOW_RES, MID_RES, HIGH_RES);
  667.   FUNCTION      getres : aufloesung;                    XBIOS (4);
  668. BEGIN
  669.   hide_mouse;
  670.   set_clip( fenst_x, fenst_y, fenst_w, fenst_h);
  671.   IF getres = HIGH_RES
  672.   THEN paint_color( BLACK)
  673.   ELSE paint_color( GREEN);
  674.   paint_style( MUSTER);
  675.   paint_rect( fenst_x, fenst_y, fenst_w, fenst_h);
  676.   show_mouse;
  677. END; { procedure redraw_hintergrund }
  678.  
  679.  
  680. {///////////////////////////////////////////////////////////////////////////}
  681. {///   Reagiert auf Aktionen im Dialogfeld   ///////////////////////////////}
  682. {///////////////////////////////////////////////////////////////////////////}
  683.  
  684. PROCEDURE action;
  685. VAR     i       : INTEGER;
  686. BEGIN                           { Eigenes großes Fenster als Hintergrund }
  687.   fenstername := '';            { sonst Störung durch fremdes WM_REDRAW  }
  688.   fenster := new_window( NONE, fenstername, 0, 0, 0, 0 );
  689.   open_window ( fenster, 0, 0, 0, 0 );
  690.   work_rect( fenster, fenst_x, fenst_y, fenst_w, fenst_h);
  691.   redraw_hintergrund;
  692.  
  693.   set_mouse( M_ARROW);
  694.   erlaubte_laufwerke;   { Feststellen, welche Laufwerke verfügbar sind }
  695.   erfolg := FALSE;
  696.  
  697.   wahl := do_dialog( dl, quell_drive);
  698.  
  699.   LOOP                  { bis Cancel_btn gewählt oder erfolgreich kopiert }
  700.     kopier_stop := FALSE;
  701.  
  702.     get_dedit( dl, quell_drive, q_dr_str);      { Laufwerksangaben holen }
  703.     get_dedit( dl, ziel_drive,  z_dr_str);
  704.  
  705.     IF ( q_dr_str[1] <> q_drive) AND ( length(q_dr_str) > 0 )
  706.     THEN IF upcase( q_dr_str[1]) IN angemeldet
  707.          THEN q_drive := upcase( q_dr_str[1])
  708.          ELSE nicht_angemeldet_alarm( upcase( q_dr_str[1]) );
  709.  
  710.     IF ( z_dr_str[1] <> z_drive) AND ( length(z_dr_str) > 0 )
  711.     THEN IF upcase( z_dr_str[1]) IN angemeldet
  712.          THEN z_drive := upcase( z_dr_str[1])
  713.          ELSE nicht_angemeldet_alarm( upcase( z_dr_str[1]) );
  714.  
  715.     in_fil_pfad[1]  := q_drive;                 { Laufwerke setzen }
  716.     out_fil_pfad[1] := z_drive;
  717.  
  718.     IF wahl IN [ quell_btn, ziel_btn, ordner_btn]
  719.     THEN redraw_hintergrund;    { Fenster ausmalen für File-Selector-Box }
  720.  
  721.     IF ( wahl = start_btn ) AND NOT kopier_stop
  722.     THEN IF in_fil_pfad = out_fil_pfad
  723.          THEN BEGIN             { Kein Backup, da Quelle und Ziel identisch }
  724.                 t := concat( '[3][Quell- und Zieldatei| |',
  725.                              'sind identisch][ABBRUCH]');
  726.                 mist := do_alert( t, 1);
  727.               END { Backup abgelehnt }
  728.          ELSE BEGIN
  729.                 set_mouse( M_BEE);
  730.                 erfolg := backup( in_fil_pfad, out_fil_pfad);   { kopieren }
  731.                 set_mouse( M_ARROW);
  732.               END;
  733.  
  734.     IF wahl = quell_btn  THEN suche_quelldatei;
  735.     IF wahl = ziel_btn   THEN suche_zieldatei;
  736.     IF wahl = ordner_btn THEN neuer_ordner;
  737.  
  738.     IF wahl IN [ quell_btn, ziel_btn, ordner_btn]
  739.     THEN redraw_hintergrund;    { Fenster wieder ausmalen für Dialog }
  740.  
  741.     IF wahl <> cancel_btn
  742.     THEN
  743.     BEGIN                                       { Laufwerke neu setzen }
  744.       set_dedit ( dl, quell_drive, '_', 'a', q_drive,SYSTEM_FONT, TE_CENTER);
  745.       set_dedit ( dl,  ziel_drive, '_', 'a', z_drive,SYSTEM_FONT, TE_CENTER);
  746.  
  747.       IF length( in_fil_pfad)  > 0      { neue Info - Texte festlegen }
  748.       THEN set_dtext( dl, quell_name, in_fil_pfad,  SYSTEM_FONT, TE_LEFT)
  749.       ELSE set_dtext( dl, quell_name, frag_leer,    SYSTEM_FONT, TE_LEFT);
  750.  
  751.       IF length( out_fil_pfad) > 0
  752.       THEN set_dtext( dl, ziel_name, out_fil_pfad, SYSTEM_FONT, TE_LEFT)
  753.       ELSE set_dtext( dl, ziel_name, frag_leer,    SYSTEM_FONT, TE_LEFT);
  754.     END; { Cancel_btn wurde nicht gewählt }
  755.                                         { SELECTED - Status zurücknehmen }
  756.     obj_setstate( dl, wahl, obj_state( dl, wahl) & ~ SELECTED , FALSE);
  757.  
  758.   EXIT IF ( wahl = cancel_btn ) OR erfolg;
  759.     wahl := do_dialog( dl, quell_drive);
  760.   END; { loop-Schleife }
  761.  
  762.   end_dialog( dl);
  763.   close_window  ( fenster );    { Hintergrundfenster wieder entfernen }
  764.   delete_window ( fenster );
  765. END; { procedure action }                       { Zurück in event_loop }
  766.  
  767.  
  768. {///////////////////////////////////////////////////////////////////////////}
  769. {///   Schaut immer nur, ob das Programm endlich gebraucht wird   //////////}
  770. {///////////////////////////////////////////////////////////////////////////}
  771.  
  772. PROCEDURE event_loop;
  773. VAR     event   : INTEGER;
  774.         msg     : message_buffer;
  775. BEGIN
  776.   REPEAT
  777.     event := get_event( E_MESSAGE, 0, 0, 0, 0,
  778.                         FALSE, 0, 0, 0, 0, FALSE, 0, 0, 0, 0,
  779.                         msg, mist, mist, mist, mist, mist, mist);
  780.     CASE msg[0] OF AC_OPEN  : action;
  781.                    AC_CLOSE : BEGIN END;
  782.     END; { case }
  783.   UNTIL TRUE = FALSE;           { Wartet bis zum Stromausfall auf Aufruf }
  784. END; { procedure event_loop }
  785.  
  786. {///////////////////////////////////////////////////////////////////////////}
  787.  
  788. BEGIN { Hauptprogramm }
  789.   ap_id := init_gem;
  790.   IF ap_id >= 0
  791.   THEN
  792.   BEGIN
  793.     acc_name := MENU_EINTRAG;
  794.     menu_id := menu_register( ap_id, acc_name);
  795.     erlaubte_laufwerke;
  796.     initialisiere;
  797.     baue_dialog;
  798.     center_dialog( dl);
  799.     event_loop;
  800. {   exit_gem; Wird nie gebraucht, da es sich ein Accessory handelt }
  801.   END; { init_gem erfolgreich }
  802.  
  803. END.
  804.  
  805.